week 9: advanced methods
measurement
In measurement theory, we may assume that
\[ X_i = T_i + \epsilon_i \]
Meaning that for any observation \(i\), the observed score \(X\) on some measure is the sum of the true score \(T\) and error \(\epsilon\). Classical test theory assumes that \(\epsilon_i\) is randomly distributed, but other theories (IRT) disagree. Regardless, we can move forward with the assumption that observed scores are caused by some true score and some error.
Code
dag_coords <-
tibble(name = c("A", "M", "D", "Dobs", "eD"),
x = c(1, 2, 2, 3, 4),
y = c(2, 3, 1, 1, 1))
dagify(M ~ A,
D ~ A + M,
Dobs ~ D + eD,
coords = dag_coords) %>%
tidy_dagitty() %>%
mutate(color = ifelse(name %in% c("D", "eD"), "a", "b")) %>%
ggplot(aes(x = x, y = y, xend = xend, yend = yend)) +
geom_dag_point(aes(color = color),
size = 10, show.legend = F) +
geom_dag_text(parse = T, label = c("A", "D", expression(D[obs]),
"M",expression(italic(e)[D]))) +
geom_dag_edges() +
theme_void()
Code
p1 <- d %>%
ggplot(aes(x = MedianAgeMarriage,
y = Divorce,
ymin = Divorce - Divorce.SE,
ymax = Divorce + Divorce.SE)) +
geom_pointrange(shape = 20, alpha = 2/3, color="#1c5253") +
labs(x = "Median age marriage" ,
y = "Divorce rate")
p2 <-
d %>%
ggplot(aes(x = log(Population),
y = Divorce,
ymin = Divorce - Divorce.SE,
ymax = Divorce + Divorce.SE)) +
geom_pointrange(shape = 20, alpha = 2/3, color="#e07a5f") +
scale_y_continuous(NULL, breaks = NULL) +
xlab("log population")
p1 | p2
Code
states <- c("AL", "AR", "ME", "NH", "RI", "DC", "VT", "AK", "SD", "UT", "ID", "ND", "WY")
d_est <-
posterior_summary(m1) %>%
data.frame() %>%
rownames_to_column("term") %>%
mutate(D_est = Estimate) %>%
select(term, D_est) %>%
filter(str_detect(term, "Yl")) %>%
bind_cols(d)
d_est %>%
ggplot(aes(x = D_sd, y = D_est - D_obs)) +
geom_hline(yintercept = 0, linetype = 2) +
geom_point(alpha = 2/3) +
geom_text_repel(data = . %>% filter(Loc %in% states),
aes(label = Loc),
size = 3, seed = 15) 
Code
states <- c("AR", "ME", "RI", "ID", "WY", "ND", "MN")
as_draws_df(m1) %>%
expand_grid(A = seq(from = -3.5, to = 3.5, length.out = 50)) %>%
mutate(fitted = b_Intercept + b_A * A) %>%
ggplot(aes(x = A)) +
stat_lineribbon(aes(y = fitted),
.width = .95, size = 1/3,
color = "grey20",
fill = "grey80") +
geom_segment(data = d_est,
aes(xend = A, y = D_obs, yend = D_est),
linewidth = 1/5) +
geom_point(data = d_est,
aes(y = D_obs)) +
geom_point(data = d_est,
aes(y = D_est),
shape = 1, stroke = 1/3) +
geom_text_repel(data = d %>% filter(Loc %in% states),
aes(y = D_obs, label = Loc),
size = 3, seed = 15) +
labs(x = "median age marriage (std)",
y = "divorce rate (std)") +
coord_cartesian(xlim = range(d$A),
ylim = range(d$D_obs))